home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue47 / Alfresco / AADate.pas next >
Encoding:
Pascal/Delphi Source File  |  1999-05-23  |  29.8 KB  |  1,021 lines
  1. {*********************************************************}
  2. {* AADate.PAS                                            *}
  3. {* Copyright (c) Julian M Bucknall 1993 - 1999           *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Date arithmetic routines                              *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. unit AADate;
  14.  
  15. interface
  16.  
  17. uses
  18.   SysUtils,
  19.   Classes;
  20.  
  21. type
  22.   TaaDate = longint;
  23.   TaaDOW = (aaSunday, aaMonday, aaTuesday, aaWednesday,
  24.             aaThursday, aaFriday, aaSaturday);
  25.   TaaDateFormat = (  {Date string formats..}
  26.         dfWindows,   {..Windows defined}
  27.         dfLotus,     {..dd-Mmm-yyyy}
  28.         dfLotusDOW,  {..Ddd dd-Mmm-yyyy}
  29.         dfDMY,       {..dd/mm/yyyy}
  30.         dfMDY,       {..mm/dd/yyyy}
  31.         dfYMD);      {..yyyy/mm/dd}
  32.  
  33. type
  34.   TaaHolidayList = class
  35.     private
  36.       FList   : TList;
  37.       FWEDays : array [aaSunday..aaSaturday] of boolean;
  38.     protected
  39.       function hlGetHolidayCount : integer;
  40.       function hlGetItem(aInx : integer) : TaaDate;
  41.       function hlGetWeekend(aDOW : TaaDOW) : boolean;
  42.       procedure hlSetWeekend(aDOW : TaaDOW; aValue : boolean);
  43.  
  44.       procedure hlStreamRead(aStream : TStream;
  45.                          var aBuffer; aCount : longint);
  46.       procedure hlStreamWrite(aStream : TStream;
  47.                           var aBuffer; aCount : longint);
  48.     public
  49.       constructor Create;
  50.         {-create instance, set weekend to Sat/Sun}
  51.       destructor Destroy; override;
  52.         {-free instance}
  53.  
  54.       procedure AddHoliday(aDate : TaaDate);
  55.         {-add a new holiday}
  56.       procedure Clear;
  57.         {-clear all holidays, set weekend to Sat/Sun}
  58.       procedure ClearBefore(aDate : TaaDate);
  59.         {-clear all holidays before a certain date, leave weekend}
  60.       procedure DeleteHoliday(aDate : TaaDate);
  61.         {-delete a single holiday (no error if not there)}
  62.  
  63.       function IsBusinessDay(aDate : TaaDate) : boolean;
  64.         {-return true if the day is not a weekend or holiday}
  65.       function BusinessDaysDiff(aDate1, aDate2 : TaaDate) : integer;
  66.         {-return the number of business days between aDate1 and
  67.           aDate2; aDate1 <= aDate2, otherwise they're swapped over;
  68.           count starts from aDate+1}
  69.       function NextBusinessDay(aDate : TaaDate) : TaaDate;
  70.         {-return the next business day from aDate}
  71.       function PrevBusinessDay(aDate : TaaDate) : TaaDate;
  72.         {-return the previous business day from aDate}
  73.       function NearestBusinessDay(aDate      : TaaDate;
  74.                                   aSameMonth : boolean) : TaaDate;
  75.         {-return the nearest business day to aDate; is aDate is a
  76.           business day then it is returned, otherwise the next
  77.           business day from aDate is returned; if aSameMonth is true,
  78.           the date returned is forced to be in the same month as
  79.           aDate.}
  80.  
  81.       procedure LoadFromStream(aStream : TStream);
  82.         {-clear object, load data from stream}
  83.       procedure StoreToStream(aStream : TStream);
  84.         {-store objact data to stream}
  85.  
  86.       property Weekend[aDOW : TaaDOW] : boolean
  87.          read hlGetWeekend write hlSetWeekend;
  88.         {-for each day: weekend day if true, normal day if false}
  89.       property HolidayCount : integer
  90.          read hlGetHolidayCount;
  91.       property Holidays[aInx : integer] : TaaDate
  92.          read hlGetItem; default;
  93.         {-holiday date list (sorted)}
  94.   end;
  95.  
  96.  
  97. {--basic routines---}
  98. function aaYMDToDate(Y, M, D : integer) : TaaDate;
  99. procedure aaDateToYMD(aDate : TaaDate; var Y, M, D : integer);
  100. function aaIsLeapYear(Y : integer) : boolean;
  101. function aaDaysInMonth(Y, M : integer) : integer;
  102. function aaToday : TaaDate;
  103.  
  104. {--conversion to/from other formats--}
  105. function aaDateToTDateTime(aDate : TaaDate) : TDateTime;
  106. function aaTDateTimeToDate(aDate : TDateTime) : TaaDate;
  107. function aaDateToStDate(aDate : TaaDate) : longint;
  108. function aaStDateToDate(aDate : longint) : TaaDate;
  109. function aaDateToGregDate(aDate : TaaDate) : longint;
  110. function aaGregDateToDate(aDate : longint) : TaaDate;
  111. procedure aaDateToISODate(aDate : TaaDate; var Y, W, D : integer);
  112. function aaISODateToDate(Y, W, D : integer) : TaaDate;
  113.  
  114. {--month arithmetic--}
  115. function aaDateAddMonths(aDate : TaaDate; aMonths : integer;
  116.                          aStickyMonthEnds : boolean) : TaaDate;
  117. function aaDateDiffInMonths(aDate1, aDate2 : TaaDate;
  118.                             aStickyMonthEnds : boolean;
  119.                         var aDays : integer) : integer;
  120.  
  121.  
  122. {--day of week arithmetic---}
  123. function aaDayOfWeek(aDate : TaaDate) : TaaDOW;
  124. function aaIsDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : boolean;
  125. function aaNextDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : TaaDate;
  126. function aaPrevDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : TaaDate;
  127.  
  128. {---validation---}
  129. function aaIsValidYMD(Y, M, D : integer) : boolean;
  130. function aaIsValidDate(aDate : TaaDate) : boolean;
  131.  
  132. {---string representation---}
  133. function aaDateToStr(aDate : TaaDate; aFormat : TaaDateFormat) : string;
  134. function aaShortDayName(aDOW : TaaDOW) : string;
  135. function aaLongDayName(aDOW : TaaDOW) : string;
  136.  
  137. implementation
  138.  
  139. {$IFDEF Win32}
  140. uses
  141.   Windows;
  142. {$ENDIF}
  143.  
  144. type
  145.   PFirstJanuarys = ^TFirstJanuarys;
  146.   TFirstJanuarys = array [0..400] of TaaDate;
  147.  
  148.   PCumulativeDays = ^TCumulativeDays;
  149.   TCumulativeDays = array [boolean, 0..12] of word;
  150.  
  151. const
  152.   DaysInMonth : array [1..13] of byte =
  153.                 (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 0);
  154.   DaysInFeb = 28;
  155.   DaysInLeapFeb = 29;
  156.   MaxDate = 146096; {date values range from 0 to 146096}
  157.   MinYear = 1800;   {year values range from 1800..}
  158.   MaxYear = 2199;   {..to 2199}
  159.   MaxMonth = 4799;  {month values range from 0 to 4799}
  160.   DOW18000101 = aaWednesday;  {1 Jan 1800 was a Wednesday}
  161.   {$IFDEF Windows}
  162.   MagicTDateTime = -657072;
  163.   {$ELSE}
  164.   MagicTDateTime = 36522;
  165.   {$ENDIF}
  166.   MagicStDate = -73049;
  167.  
  168. var
  169.   FirstJanuarys : PFirstJanuarys;
  170.   CumulativeDays : PCumulativeDays;
  171.   WindowsDateFormat : TaaDateFormat;
  172.  
  173. {===Primitives=======================================================}
  174. function IsLeapYearPrim(Y : integer) : boolean;
  175. begin
  176.   {assumes Y is valid}
  177.   Result := ((Y mod 4) = 0) and
  178.             (Y <> 1800) and (Y <> 1900) and (Y <> 2100);
  179. end;
  180. {--------}
  181. function DaysInMonthPrim(Y, M : integer) : integer;
  182. begin
  183.   if (M = 2) and IsLeapYearPrim(Y) then
  184.     Result := DaysInLeapFeb
  185.   else
  186.     Result := DaysInMonth[M];
  187. end;
  188. {====================================================================}
  189.  
  190.  
  191. {===Interfaced routines==============================================}
  192. function aaDateAddMonths(aDate : TaaDate; aMonths : integer;
  193.                          aStickyMonthEnds : boolean) : TaaDate;
  194. var
  195.   Y, M, D : integer;
  196.   DaysInM : integer;
  197.   StickToMonthEnd : boolean;
  198. begin
  199.   aaDateToYMD(aDate, Y, M, D);
  200.   StickToMonthEnd := aStickyMonthEnds and (D = DaysInMonthPrim(Y, M));
  201.   {calculate the month number from January 1800}
  202.   M := (Y - MinYear) * 12 + pred(M) + aMonths;
  203.   {if its out of range say so}
  204.   if (M < 0) or (M > MaxMonth) then
  205.     raise Exception.Create('aaDateAddMonths: calculated date in out of range');
  206.   {calculate the new year and month}
  207.   Y := (M div 12) + MinYear;
  208.   M := succ(M mod 12);
  209.   {check to see that the date is in range for the month}
  210.   DaysInM := DaysInMonthPrim(Y, M);
  211.   if StickToMonthEnd or (D > DaysInM) then
  212.     D := DaysInM;
  213.   Result := aaYMDToDate(Y, M, D);
  214. end;
  215. {--------}
  216. function aaDateDiffInMonths(aDate1, aDate2 : TaaDate;
  217.                             aStickyMonthEnds : boolean;
  218.                         var aDays : integer) : integer;
  219. var
  220.   TempDate : TaaDate;
  221.   Y1, M1, D1 : integer;
  222.   Y2, M2, D2 : integer;
  223.   Date1AtME  : boolean;
  224.   Date2AtME  : boolean;
  225. begin
  226.   {make sure that aDate1 is less than aDate2}
  227.   if (aDate1 > aDate2) then begin
  228.     TempDate := aDate1;
  229.     aDate1 := aDate2;
  230.     aDate2 := TempDate;
  231.   end;
  232.   {convert dates to YMD}
  233.   aaDateToYMD(aDate1, Y1, M1, D1);
  234.   aaDateToYMD(aDate2, Y2, M2, D2);
  235.   {make first approximation to answer}
  236.   Result := ((Y2 - Y1) * 12) + (M2 - M1);
  237.   {if both day numbers are less then 28, we don't have to worry about
  238.    any month end calculations}
  239.   if (D1 < 28) and (D2 < 28) then begin
  240.     {if the first day is less than or equal to the second, then the
  241.      day count is just the difference}
  242.     if (D1 <= D2) then
  243.       aDays := D2 - D1
  244.     {otherwise, the month count is one too many, then we have to count
  245.      the number of days from Y2/(M2-1)/D1 to Y2/M2/D2; the former date
  246.      being Result whole months from aDate1}
  247.     else begin
  248.       dec(Result);
  249.       dec(M2);
  250.       if (M2 = 0) then begin
  251.         M2 := 12;
  252.         dec(Y2);
  253.       end;
  254.       if (D1 > DaysInMonthPrim(Y2, M2)) then
  255.         D1 := DaysInMonthPrim(Y2, M2);
  256.       aDays := aDate2 - aaYMDToDate(Y2, M2, D1);
  257.     end;
  258.     Exit;
  259.   end;
  260.   {if we reach this point, one or both of the dates might be at a
  261.    month end, so *beware*}
  262.   Date1AtME := D1 = DaysInMonthPrim(Y1, M1);
  263.   Date2AtME := D2 = DaysInMonthPrim(Y2, M2);
  264.   {the easiest case is both days are at month ends and we want sticky
  265.    month ends: we're done after setting aDays to zero}
  266.   if aStickyMonthEnds and Date1AtME and Date2AtME then begin
  267.     aDays := 0;
  268.     Exit;
  269.   end;
  270.   {the next easiest cases all use sticky month ends}
  271.   if aStickyMonthEnds then begin
  272.     {if the first date is at a month end (the second won't be) then
  273.      the number of months is one too many, and the number of days is
  274.      equal to the second day value}
  275.     if Date1AtME then begin {note: Date2AtME = false}
  276.       dec(Result);
  277.       aDays := D2;
  278.       Exit;
  279.     end;
  280.     {if the second date is at a month end (the first won't be) then
  281.      the number of months is correct, and the number of days is
  282.      equal to the second day value minus the first, or zero if this
  283.      is negative}
  284.     if Date2AtME then begin {note: Date1AtME = false}
  285.       if D2 >= D1 then
  286.         aDays := D2 - D1
  287.       else
  288.         aDays := 0;
  289.       Exit;
  290.     end;
  291.   end;
  292.   {if the second day number is greater or equal to the first, the
  293.    number of days is the difference; the number of months is correct}
  294.   if (D2 >= D1) then begin
  295.     aDays := D2 - D1;
  296.     Exit;
  297.   end;
  298.   {otherwise, the number of months is one too many, and the number of
  299.    days is that from Y2/(M2-1)/D1 to Y2/M2/D2}
  300.   dec(Result);
  301.   dec(M2);
  302.   if (M2 = 0) then begin
  303.     M2 := 12;
  304.     dec(Y2);
  305.   end;
  306.   if (D1 > DaysInMonthPrim(Y2, M2)) then
  307.     D1 := DaysInMonthPrim(Y2, M2);
  308.   aDays := aDate2 - aaYMDToDate(Y2, M2, D1);
  309. end;
  310. {--------}
  311. function aaDateToGregDate(aDate : TaaDate) : longint;
  312. var
  313.   Y, M, D : integer;
  314. begin
  315.   aaDateToYMD(aDate, Y, M, D);
  316.   Result := (((longint(Y) * 100) + M) * 100) + D;
  317. end;
  318. {--------}
  319. procedure aaDateToISODate(aDate : TaaDate; var Y, W, D : integer);
  320. var
  321.   xY, xM, xD : integer;
  322.   FirstWeek  : TaaDate;
  323.   FirstWeekNext  : TaaDate;
  324. begin
  325.   {Notes: an ISO date is defined by the year, week number and day
  326.           within the week. A week starts on a Monday and this is day 1
  327.           (hence Sunday is day 7). The first week of the year is the
  328.           one that contains the first Thursday of the year.
  329.           Clever Stuff Dept: Week 1 of year Y starts on the first
  330.           Monday after 28 December, (Y-1); of course, *that* is 4 days
  331.           before 1 January, Y}
  332.   aaDateToYMD(aDate, xY, xM, xD);
  333.   FirstWeek := aaNextDayOfWeek(FirstJanuarys^[xY-MinYear]-4, aaMonday);
  334.   if (aDate < FirstWeek) then begin
  335.     dec(xY);
  336.     FirstWeek := aaNextDayOfWeek(FirstJanuarys^[xY-MinYear]-4, aaMonday);
  337.   end
  338.   else begin
  339.     FirstWeekNext := aaNextDayOfWeek(FirstJanuarys^[xY-MinYear+1]-4, aaMonday);
  340.     if (aDate >= FirstWeekNext) then begin
  341.       inc(xY);
  342.       FirstWeek := FirstWeekNext;
  343.     end;
  344.   end;
  345.   Y := xY;
  346.   W := succ((aDate - FirstWeek) div 7);
  347.   D := succ((aDate - FirstWeek) mod 7);
  348. end;
  349. {--------}
  350. function aaDateToStr(aDate : TaaDate; aFormat : TaaDateFormat) : string;
  351. var
  352.   Y, M, D : integer;
  353.   DOW     : TaaDOW;
  354. begin
  355.   aaDateToYMD(aDate, Y, M, D);
  356.   if aFormat = dfWindows then
  357.     aFormat := WindowsDateFormat;
  358.   case aFormat of
  359.     dfLotus :
  360.       begin
  361.         Result := Format('%2d-%s-%d',
  362.                          [D, ShortMonthNames[M], Y]);
  363.       end;
  364.     dfLotusDOW :
  365.       begin
  366.         DOW := aaDayOfWeek(aDate);
  367.         Result := Format('%s %2d-%s-%d',
  368.                          [ShortDayNames[succ(ord(DOW))],
  369.                           D, ShortMonthNames[M], Y]);
  370.       end;
  371.     dfDMY :
  372.       begin
  373.         Result := Format('%2d-%2d-%d', [D, M, Y]);
  374.         if Result[4] = ' ' then
  375.             Result[4] := '0';
  376.         Result[3] := DateSeparator;
  377.         Result[6] := DateSeparator;
  378.       end;
  379.     dfMDY :
  380.       begin
  381.         Result := Format('%2d-%2d-%d', [M, D, Y]);
  382.         if Result[4] = ' ' then
  383.             Result[4] := '0';
  384.         Result[3] := DateSeparator;
  385.         Result[6] := DateSeparator;
  386.       end;
  387.     dfYMD :
  388.       begin
  389.         Result := Format('%d-%2d-%2d', [Y, M, D]);
  390.         if Result[6] = ' ' then
  391.             Result[6] := '0';
  392.         if Result[9] = ' ' then
  393.             Result[9] := '0';
  394.         Result[5] := DateSeparator;
  395.         Result[8] := DateSeparator;
  396.       end;
  397.   else
  398.     Result := '';
  399.   end;
  400. end;
  401. {--------}
  402. function aaDateToStDate(aDate : TaaDate) : longint;
  403. begin
  404.   if (aDate < 0) or (aDate > MaxDate) then
  405.     raise Exception.Create('aaDateToStDate: invalid date');
  406.   Result := aDate - MagicStDate;
  407. end;
  408. {--------}
  409. function aaDateToTDateTime(aDate : TaaDate) : TDateTime;
  410. begin
  411.   if (aDate < 0) or (aDate > MaxDate) then
  412.     raise Exception.Create('aaDateToTDateTime: invalid date');
  413.   Result := aDate - MagicTDateTime;
  414. end;
  415. {--------}
  416. procedure aaDateToYMD(aDate : TaaDate; var Y, M, D : integer);
  417. {.$DEFINE SequentialSearch}
  418. {.$DEFINE BinarySearch}
  419. {$DEFINE InterpolationSearch}
  420. var
  421.   Inx : integer;
  422.   IsLeap : boolean;
  423.   {$IFDEF SequentialSearch}
  424.   FoundIt : boolean;
  425.   {$ENDIF}
  426.   {$IFDEF BinarySearch}
  427.   FoundIt : boolean;
  428.   L, Mid, R : integer;
  429.   {$ENDIF}
  430. begin
  431.   if (aDate < 0) or (aDate > MaxDate) then
  432.     raise Exception.Create('aaDateToYMD: invalid date');
  433.   {$IFDEF SequentialSearch}
  434.   FoundIt := true;
  435.   for Inx := 0 to 400 do
  436.     if (aDate < FirstJanuarys^[Inx]) then begin
  437.       FoundIt := true;
  438.       Break;
  439.     end;
  440.   if FoundIt then
  441.     dec(Inx)
  442.   else
  443.     Inx := 399;
  444.   {$ENDIF}
  445.   {$IFDEF BinarySearch}
  446.   FoundIt := false;
  447.   L := 0;
  448.   R := 400;
  449.   while (L <= R) do begin
  450.     Mid := (L + R) div 2;
  451.     if (aDate < FirstJanuarys^[Mid]) then
  452.       R := pred(Mid)
  453.     else if (aDate > FirstJanuarys^[Mid]) then
  454.       L := succ(Mid)
  455.     else {equal} begin
  456.       FoundIt := true;
  457.       Break;
  458.     end;
  459.   end;
  460.   if FoundIt then
  461.     Inx := Mid
  462.   else
  463.     Inx := L-1;
  464.   {$ENDIF}
  465.   {$IFDEF InterpolationSearch}
  466.   {use interpolation search to calculate 1 January, & hence the year}
  467.   Inx := aDate div 365;
  468.   if (aDate < FirstJanuarys^[Inx]) then
  469.     dec(Inx);
  470.   {$ENDIF}
  471.   Y := MinYear + Inx;
  472.   IsLeap := ((Inx mod 4) = 0) and
  473.             (Inx <> 0) and (Inx <> 100) and (Inx <> 300);
  474.   {use interpolation search to calculate the month}
  475.   aDate := aDate - FirstJanuarys^[Inx];
  476.   Inx := (aDate div 32) + 1;
  477.   if (aDate < CumulativeDays^[IsLeap, Inx]) then
  478.     dec(Inx);
  479.   M := succ(Inx);
  480.   {calculate the day}
  481.   D := aDate - CumulativeDays^[IsLeap, Inx] + 1;
  482. end;
  483. {--------}
  484. function aaDayOfWeek(aDate : TaaDate) : TaaDOW;
  485. begin
  486.   if (aDate < 0) or (aDate > MaxDate) then
  487.     raise Exception.Create('aaDayOfWeek: invalid date');
  488.   Result := TaaDOW((aDate + ord(DOW18000101)) mod 7);
  489. end;
  490. {--------}
  491. function aaDaysInMonth(Y, M : integer) : integer;
  492. begin
  493.   if (Y < MinYear) or (Y > MaxYear) or
  494.      (M < 1) or (M > 12) then
  495.     raise Exception.Create('aaDaysInMonth: invalid year and/or month');
  496.   if (M = 2) and IsLeapYearPrim(Y) then
  497.     Result := DaysInLeapFeb
  498.   else
  499.     Result := DaysInMonth[M];
  500. end;
  501. {--------}
  502. function aaGregDateToDate(aDate : longint) : TaaDate;
  503. var
  504.   Y, M, D : integer;
  505. begin
  506.   Y := aDate div 10000;
  507.   M := (aDate mod 10000) div 100;
  508.   D := aDate mod 100;
  509.   Result := aaYMDToDate(Y, M, D);
  510. end;
  511. {--------}
  512. function aaIsDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : boolean;
  513. begin
  514.   Result := aaDayOfWeek(aDate) = aDOW;
  515. end;
  516. {--------}
  517. function aaIsLeapYear(Y : integer) : boolean;
  518. begin
  519.   if (Y < MinYear) or (Y > MaxYear) then
  520.     raise Exception.Create('aaIsLeapYear: invalid year, should be 1800-2199');
  521.   Result := ((Y mod 4) = 0) and
  522.             (Y <> 1800) and (Y <> 1900) and (Y <> 2100);
  523. end;
  524. {--------}
  525. function aaISODateToDate(Y, W, D : integer) : TaaDate;
  526. var
  527.   FirstWeek : TaaDate;
  528. begin
  529.   {Notes: an ISO date is defined by the year, week number and day
  530.           within the week. A week starts on a Monday and this is day 1
  531.           (hence Sunday is day 7). The first week of the year is the
  532.           one that contains the first Thursday of the year.
  533.           Clever Stuff Dept: Week 1 of year Y starts on the first
  534.           Monday after 28 December, (Y-1); of course, *that* is 4 days
  535.           before 1 January, Y}
  536.   if (Y < MinYear) or (Y > MaxYear) then
  537.     raise Exception.Create('aaISODateToDate: invalid year, should be 1800-2199');
  538.   if (W < 1) or (W > 53) then
  539.     raise Exception.Create('aaISODateToDate: invalid week, should be 1-53');
  540.   if (D < 1) or (D > 7) then
  541.     raise Exception.Create('aaISODateToDate: invalid day, should be 1 (Monday) to 7 (Sunday)');
  542.   FirstWeek := aaNextDayOfWeek(FirstJanuarys^[Y-MinYear]-4, aaMonday);
  543.   Result := FirstWeek + ((W - 1) * 7) + (D - 1);
  544. end;
  545. {--------}
  546. function aaIsValidDate(aDate : TaaDate) : boolean;
  547. begin
  548.   Result := (0 <= aDate) and (aDate <= MaxDate);
  549. end;
  550. {--------}
  551. function aaIsValidYMD(Y, M, D : integer) : boolean;
  552. begin
  553.   Result := false;
  554.   {easy checks}
  555.   if (Y < MinYear) or (Y > MaxYear) then Exit;
  556.   if (M < 1) or (M > 12) then Exit;
  557.   if (D < 1) then Exit;
  558.   {full check on day}
  559.   if (D > 28) then begin
  560.     {if February..}
  561.     if (M = 2) then begin
  562.       {if leap year..}
  563.       if ((Y mod 4) = 0) and
  564.          (Y <> 1800) and (Y <> 1900) and (Y <> 2100) then begin
  565.         if (D > DaysInLeapFeb) then Exit;
  566.       end
  567.       else
  568.         if (D > DaysInFeb) then Exit;
  569.     end
  570.     else
  571.       if (D > DaysInMonth[M]) then Exit;
  572.   end;
  573.   {otherwise it's OK}
  574.   Result := true;
  575. end;
  576. {--------}
  577. function aaLongDayName(aDOW : TaaDOW) : string;
  578. begin
  579.   Result := LongDayNames[succ(ord(aDOW))];
  580. end;
  581. {--------}
  582. function aaNextDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : TaaDate;
  583. var
  584.   ThisDOW : TaaDOW;
  585. begin
  586.   ThisDOW := aaDayOfWeek(aDate);
  587.   Result := aDate + (ord(aDOW) - ord(ThisDOW));
  588.   if (ThisDOW >= aDOW) then
  589.     inc(Result, 7);
  590.   if (Result < 0) or (Result > MaxDate) then
  591.     raise Exception.Create('aaNextDayOfWeek: calculated date out of range');
  592. end;
  593. {--------}
  594. function aaPrevDayOfWeek(aDate : TaaDate; aDOW : TaaDOW) : TaaDate;
  595. var
  596.   ThisDOW : TaaDOW;
  597. begin
  598.   ThisDOW := aaDayOfWeek(aDate);
  599.   Result := aDate + (ord(aDOW) - ord(ThisDOW));
  600.   if (ThisDOW <= aDOW) then
  601.     dec(Result, 7);
  602.   if (Result < 0) or (Result > MaxDate) then
  603.     raise Exception.Create('aaPrevDayOfWeek: calculated date out of range');
  604. end;
  605. {--------}
  606. function aaShortDayName(aDOW : TaaDOW) : string;
  607. begin
  608.   Result := ShortDayNames[succ(ord(aDOW))];
  609. end;
  610. {--------}
  611. function aaStDateToDate(aDate : longint) : TaaDate;
  612. begin
  613.   Result := aDate + MagicStDate;
  614.   if (Result < 0) or (Result > MaxDate) then
  615.     raise Exception.Create('aaStDateToDate: invalid date');
  616. end;
  617. {--------}
  618. function aaTDateTimeToDate(aDate : TDateTime) : TaaDate;
  619. begin
  620.   Result := Trunc(aDate) + MagicTDateTime;
  621.   if (Result < 0) or (Result > MaxDate) then
  622.     raise Exception.Create('aaTDateTimeToDate: invalid date');
  623. end;
  624. {--------}
  625. function aaToday : TaaDate;
  626. {$IFDEF Windows}
  627. assembler;
  628. asm
  629.   mov ah, 2Ah       {get date from DOS}
  630.   int 21h
  631.   push cx           {push year}
  632.   xor ax, ax
  633.   mov al, dh
  634.   push ax           {push month}
  635.   mov al, dl
  636.   push ax           {push day}
  637.   call aaYMDToDate  {convert}
  638. end;
  639. {$ELSE}
  640. var
  641.   SystemTime: TSystemTime;
  642. begin
  643.   GetLocalTime(SystemTime);
  644.   with SystemTime do
  645.     Result := aaYMDToDate(wYear, wMonth, wDay);
  646. end;
  647. {$ENDIF}
  648. {--------}
  649. function aaYMDToDate(Y, M, D : integer) : TaaDate;
  650. var
  651.   IsLeap : boolean;
  652. begin
  653.   if not aaIsValidYMD(Y, M, D) then
  654.     raise Exception.Create(
  655.              Format('aaYMDToDate: invalid year %d, month %d, day %d',
  656.                     [Y, M, D]));
  657.   IsLeap := ((Y mod 4) = 0) and
  658.             (Y <> 1800) and (Y <> 1900) and (Y <> 2100);
  659.   Result := FirstJanuarys^[Y-MinYear] +
  660.             CumulativeDays^[IsLeap, pred(M)] +
  661.             pred(D);
  662. end;
  663. {====================================================================}
  664.  
  665.  
  666. {===TaaHolidayList===================================================}
  667. constructor TaaHolidayList.Create;
  668. begin
  669.   inherited Create;
  670.   FList := TList.Create;
  671.   FWEDays[aaSaturday] := true;
  672.   FWEDays[aaSunday] := true;
  673. end;
  674. {--------}
  675. destructor TaaHolidayList.Destroy;
  676. begin
  677.   FList.Free;
  678.   inherited Create;
  679. end;
  680. {--------}
  681. procedure TaaHolidayList.AddHoliday(aDate : TaaDate);
  682. var
  683.   L, R, M : integer;
  684.   MidDate : TaaDate;
  685. begin
  686.   if (FList.Count = 0) then
  687.     FList.Add(pointer(aDate))
  688.   else begin
  689.     {find aDate in the list by binary search, if found, exit, if not
  690.      insert at the correct spot}
  691.     L := 0;
  692.     R := pred(FList.Count);
  693.     while L <= R do begin
  694.       M := (L + R) div 2;
  695.       MidDate := TaaDate(FList[M]);
  696.       if (aDate < MidDate) then
  697.         R := pred(M)
  698.       else if (aDate > MidDate) then
  699.         L := succ(M)
  700.       else {they're equal}
  701.         Exit;
  702.     end;
  703.     FList.Insert(L, pointer(aDate));
  704.   end;
  705. end;
  706. {--------}
  707. function TaaHolidayList.BusinessDaysDiff(aDate1, aDate2 : TaaDate) : integer;
  708. var
  709.   TempDate : TaaDate;
  710. begin
  711.   {make sure that aDate1 is less than aDate2}
  712.   if (aDate1 > aDate2) then begin
  713.     TempDate := aDate1;
  714.     aDate1 := aDate2;
  715.     aDate2 := TempDate;
  716.   end;
  717.   {count the business days from aDate1 to aDate2 inclusive}
  718.   Result := 0;
  719.   inc(aDate1);
  720.   while (aDate1 <= aDate2) do begin
  721.     if IsBusinessDay(aDate1) then
  722.       inc(Result);
  723.     inc(aDate1);
  724.   end;
  725. end;
  726. {--------}
  727. procedure TaaHolidayList.Clear;
  728. begin
  729.   FList.Clear;
  730.   FillChar(FWEDays, sizeof(FWEDays), 0);
  731.   FWEDays[aaSaturday] := true;
  732.   FWEDays[aaSunday] := true;
  733. end;
  734. {--------}
  735. procedure TaaHolidayList.ClearBefore(aDate : TaaDate);
  736. var
  737.   L, R, M : integer;
  738.   MidDate : TaaDate;
  739.   PointerList : PPointerList;
  740. begin
  741.   if (FList.Count > 0) then begin
  742.     {find aDate in the list by binary search}
  743.     L := 0;
  744.     R := pred(FList.Count);
  745.     while L <= R do begin
  746.       M := (L + R) div 2;
  747.       MidDate := TaaDate(FList[M]);
  748.       if (aDate < MidDate) then
  749.         R := pred(M)
  750.       else if (aDate > MidDate) then
  751.         L := succ(M)
  752.       else {they're equal} begin
  753.         L := M;
  754.         Break;
  755.       end;
  756.     end;
  757.     {we now have to delete all entries prior to L}
  758.     if (L > 0) then begin
  759.       PointerList := FList.List;
  760.       Move(PointerList^[L],
  761.            PointerList^[0],
  762.            (FList.Count - L) * sizeof(pointer));
  763.       FList.Count := FList.Count - L;
  764.     end;
  765.   end;
  766. end;
  767. {--------}
  768. procedure TaaHolidayList.DeleteHoliday(aDate : TaaDate);
  769. var
  770.   L, R, M : integer;
  771.   MidDate : TaaDate;
  772. begin
  773.   if (FList.Count > 0) then begin
  774.     {find aDate in the list by binary search and delete it}
  775.     L := 0;
  776.     R := pred(FList.Count);
  777.     while L <= R do begin
  778.       M := (L + R) div 2;
  779.       MidDate := TaaDate(FList[M]);
  780.       if (aDate < MidDate) then
  781.         R := pred(M)
  782.       else if (aDate > MidDate) then
  783.         L := succ(M)
  784.       else {they're equal} begin
  785.         FList.Delete(M);
  786.         Exit;
  787.       end;
  788.     end;
  789.   end;
  790. end;
  791. {--------}
  792. function TaaHolidayList.hlGetHolidayCount : integer;
  793. begin
  794.   Result := FList.Count;
  795. end;
  796. {--------}
  797. function TaaHolidayList.hlGetItem(aInx : integer) : TaaDate;
  798. begin
  799.   Result := TaaDate(FList[aInx]);
  800. end;
  801. {--------}
  802. function TaaHolidayList.hlGetWeekend(aDOW : TaaDOW) : boolean;
  803. begin
  804.   Result := FWEDays[aDOW];
  805. end;
  806. {--------}
  807. procedure TaaHolidayList.hlSetWeekend(aDOW : TaaDOW; aValue : boolean);
  808. begin
  809.   FWEDays[aDOW] := aValue;
  810. end;
  811. {--------}
  812. procedure TaaHolidayList.hlStreamRead(aStream : TStream;
  813.                                   var aBuffer; aCount : longint);
  814. var
  815.   BytesRead : longint;
  816. begin
  817.   BytesRead := aStream.Read(aBuffer, aCount);
  818.   if (BytesRead <> aCount) then
  819.     raise Exception.Create('hlStreamRead: not enough bytes read');
  820. end;
  821. {--------}
  822. procedure TaaHolidayList.hlStreamWrite(aStream : TStream;
  823.                                    var aBuffer; aCount : longint);
  824. var
  825.   BytesWrit : longint;
  826. begin
  827.   BytesWrit := aStream.Write(aBuffer, aCount);
  828.   if (BytesWrit <> aCount) then
  829.     raise Exception.Create('hlStreamWrite: not enough bytes written');
  830. end;
  831. {--------}
  832. function TaaHolidayList.IsBusinessDay(aDate : TaaDate) : boolean;
  833. var
  834.   DOW : TaaDOW;
  835.   L, R, M : integer;
  836.   MidDate : TaaDate;
  837. begin
  838.   Result := true;
  839.   {first calculate the day of the week and check whether it's a
  840.    weekend day}
  841.   DOW := aaDayOfWeek(aDate);
  842.   if FWEDays[DOW] then
  843.     Result := false
  844.   {otherwise, try to find the date in the holiday list}
  845.   else if (FList.Count <> 0) then begin
  846.     L := 0;
  847.     R := pred(FList.Count);
  848.     while L <= R do begin
  849.       M := (L + R) div 2;
  850.       MidDate := TaaDate(FList[M]);
  851.       if (aDate < MidDate) then
  852.         R := pred(M)
  853.       else if (aDate > MidDate) then
  854.         L := succ(M)
  855.       else {they're equal} begin
  856.         Result := false;
  857.         Exit;
  858.       end;
  859.     end;
  860.   end;
  861. end;
  862. {--------}
  863. procedure TaaHolidayList.LoadFromStream(aStream : TStream);
  864. var
  865.   Count : integer;
  866.   PointerList : PPointerList;
  867. begin
  868.   hlStreamRead(aStream, FWEDays, sizeof(FWEDays));
  869.   hlStreamRead(aStream, Count, sizeof(Count));
  870.   FList.Count := Count;
  871.   PointerList := FList.List;
  872.   hlStreamRead(aStream, PointerList^, Count * sizeof(pointer));
  873. end;
  874. {--------}
  875. function TaaHolidayList.NearestBusinessDay(aDate      : TaaDate;
  876.                                            aSameMonth : boolean) : TaaDate;
  877. var
  878.   Y1, M1, D1 : integer;
  879.   Y2, M2, D2 : integer;
  880. begin
  881.   if IsBusinessDay(aDate) then
  882.     Result := aDate
  883.   else begin
  884.     Result := succ(aDate);
  885.     while not IsBusinessDay(Result) do
  886.       Result := succ(Result);
  887.     if aSameMonth then begin
  888.       aaDateToYMD(aDate, Y1, M1, D1);
  889.       aaDateToYMD(Result, Y2, M2, D2);
  890.       if (M1 <> M2) then begin
  891.         Result := pred(Result);
  892.         while not IsBusinessDay(Result) do
  893.           Result := pred(Result);
  894.       end;
  895.     end;
  896.   end;
  897. end;
  898. {--------}
  899. function TaaHolidayList.NextBusinessDay(aDate : TaaDate) : TaaDate;
  900. begin
  901.   Result := succ(aDate);
  902.   while not IsBusinessDay(Result) do
  903.     Result := succ(Result);
  904. end;
  905. {--------}
  906. function TaaHolidayList.PrevBusinessDay(aDate : TaaDate) : TaaDate;
  907. begin
  908.   Result := pred(aDate);
  909.   while not IsBusinessDay(Result) do
  910.     Result := pred(Result);
  911. end;
  912. {--------}
  913. procedure TaaHolidayList.StoreToStream(aStream : TStream);
  914. var
  915.   Count : integer;
  916.   PointerList : PPointerList;
  917. begin
  918.   hlStreamWrite(aStream, FWEDays, sizeof(FWEDays));
  919.   Count := FList.Count;
  920.   hlStreamWrite(aStream, Count, sizeof(Count));
  921.   PointerList := FList.List;
  922.   hlStreamWrite(aStream, PointerList^, Count * sizeof(pointer));
  923. end;
  924. {====================================================================}
  925.  
  926.  
  927. {===Initialization and finalization==================================}
  928. procedure InitFirstJans;
  929. var
  930.   NextValue : longint;
  931.   Year      : integer;
  932. begin
  933.   {allocate the memory}
  934.   New(FirstJanuarys);
  935.   {initialize the values}
  936.   NextValue := 0;
  937.   for Year := MinYear to MaxYear do begin
  938.     FirstJanuarys^[Year-MinYear] := NextValue;
  939.     if aaIsLeapYear(Year) then
  940.       inc(NextValue, 366)
  941.     else
  942.       inc(NextValue, 365)
  943.   end;
  944.   FirstJanuarys^[400] := NextValue;
  945. end;
  946. {--------}
  947. procedure InitCumulativeDays;
  948. var
  949.   NextValue : longint;
  950.   Month     : integer;
  951. begin
  952.   {allocate the memory}
  953.   New(CumulativeDays);
  954.   {initialize the non-leap year values}
  955.   NextValue := 0;
  956.   for Month := 1 to 12 do begin
  957.     CumulativeDays^[false, pred(Month)] := NextValue;
  958.     inc(NextValue, DaysInMonth[Month]);
  959.   end;
  960.   CumulativeDays^[false, 12] := NextValue;
  961.   {initialize the non-leap year values}
  962.   NextValue := 0;
  963.   for Month := 1 to 12 do begin
  964.     CumulativeDays^[true, pred(Month)] := NextValue;
  965.     if (Month = 2) then
  966.       inc(NextValue, DaysInLeapFeb)
  967.     else
  968.       inc(NextValue, DaysInMonth[Month]);
  969.   end;
  970.   CumulativeDays^[true, 12] := NextValue;
  971. end;
  972. {--------}
  973. procedure CalcWindowsDateFormat;
  974. var
  975.   i : integer;
  976. begin
  977.   {simple calculation}
  978.   for i := 1 to length(ShortDateFormat) do
  979.     case ShortDateFormat[i] of
  980.       'd' : begin
  981.               WindowsDateFormat := dfDMY;
  982.               Exit;
  983.             end;
  984.       'm' : begin
  985.               WindowsDateFormat := dfMDY;
  986.               Exit;
  987.             end;
  988.       'y' : begin
  989.               WindowsDateFormat := dfYMD;
  990.               Exit;
  991.             end;
  992.     end;
  993.   WindowsDateFormat := dfDMY;
  994. end;
  995. {--------}
  996. procedure FinalizeUnit; far;
  997. begin
  998.   if (FirstJanuarys <> nil) then
  999.     Dispose(FirstJanuarys);
  1000.   if (CumulativeDays <> nil) then
  1001.     Dispose(CumulativeDays);
  1002. end;
  1003. {====================================================================}
  1004.  
  1005. initialization
  1006.   FirstJanuarys := nil;
  1007.   CumulativeDays := nil;
  1008.   InitFirstJans;
  1009.   InitCumulativeDays;
  1010.   CalcWindowsDateFormat;
  1011.   {$IFDEF Windows}
  1012.   AddExitProc(FinalizeUnit);
  1013.   {$ENDIF}
  1014.  
  1015. {$IFDEF Win32}
  1016. finalization
  1017.   FinalizeUnit;
  1018. {$ENDIF}
  1019.  
  1020. end.
  1021.